home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1994 August: Tool Chest / Dev.CD Aug 94.toast / Tool Chest / Development Platforms / Macintosh Common Lisp Related / interfaces / PInterface Translator / 411-reader.lisp < prev    next >
Encoding:
Text File  |  1993-09-16  |  6.0 KB  |  168 lines  |  [TEXT/CCL2]
  1. ; 411 reader. Read the 411 MPW files & extract the register trap info.
  2. ;
  3. ; Joe Chung, Apple Computers 7/90
  4. ;
  5.  
  6. ;;;;;;;;;;;;
  7. ;;
  8. ;; Modification history
  9. ;;
  10. ;; 01/02/92 bill don't (ccl:require :stream-read-line)
  11. ;; 12/19/91 bill stream-read-line -> read-line
  12. ;;               don't expect (fboundp ccl::old-trap-macro-function) to be true.
  13. ;;
  14.  
  15. (in-package :translate)
  16.  
  17. (defvar *register-trap-table* (make-hash-table :test #'eq))
  18. (defstruct rtrap
  19.   number
  20.   entry
  21.   exit)
  22.  
  23. (defvar *411-readtable* (copy-readtable nil))
  24.  
  25. (defun 411-read-self (stream char)
  26.   (declare (ignore stream))
  27.   char)
  28.  
  29. (defun 411-read-hex (stream char)
  30.   (declare (ignore char))
  31.   (let ((*read-base* 16))
  32.     (read stream)))
  33.  
  34. (set-syntax-from-char #\# #\a *411-readtable* *readtable*)
  35. (set-syntax-from-char #\, #\space *411-readtable* *readtable*)
  36. (set-syntax-from-char #\. #\space *411-readtable* *readtable*)
  37. (set-syntax-from-char #\` #\space *411-readtable* *readtable*)
  38. (set-syntax-from-char #\( #\space *411-readtable* *readtable*)
  39. (set-syntax-from-char #\) #\space *411-readtable* *readtable*)
  40. (set-syntax-from-char #\' #\" *411-readtable* *readtable*)
  41. (set-macro-character #\$ '411-read-hex nil *411-readtable*)
  42. (set-macro-character #\; '411-read-self nil *411-readtable*)
  43. (set-macro-character #\: '411-read-self nil *411-readtable*)
  44. (set-macro-character #\newline '411-read-self nil *411-readtable*)
  45.  
  46. (defun dial-411 
  47.        (&key (input-path (ccl::choose-file-dialog :button-string "dial")))
  48.   (with-open-file (istream input-path :direction :input)
  49.     (let ((*readtable* *411-readtable*)
  50.           (*package* (find-package :translate)))
  51.       (do ((line (read-line istream nil nil)
  52.                  (read-line istream nil nil))
  53.            trap-name
  54.            old-trap-mf)
  55.           ((null line))
  56.         (when (> (length line) 14)
  57.           (let ((first-six (subseq line 0 6)))
  58.             (cond ((string= first-six "æD FUN")
  59.                    (setq trap-name
  60.                          (subseq line 12 (or
  61.                                           (position #\( line :start 13)
  62.                                           (position #\: line :start 13)))))
  63.                   ((string= first-six "æD PRO")
  64.                    (setq trap-name (subseq line 13
  65.                                            (or
  66.                                             (position #\( line :start 14)
  67.                                             (position #\: line :start 14)))))
  68.                   (t
  69.                    (setq trap-name nil))))
  70.           (when trap-name
  71.             (let ((trap-number (find-trap-number trap-name))
  72.                   entry-registers exit-registers)
  73.               (when (and trap-number (or (< trap-number #xa800)
  74.                                          (and (setq old-trap-mf
  75.                                                     (old-trap-macro-function trap-name))
  76.                                               (eq old-trap-mf
  77.                                                   (fboundp 'ccl::register-trap-macro-function)))))
  78.                 (do ((token (read istream) (read istream)))
  79.                     ((eq token 'on)))
  80.                 (when (eq (read istream) 'entry)
  81.                   (setq entry-registers (read-entry-registers istream)))
  82.                 (setq exit-registers (read-exit-registers istream))
  83.                 (setf (gethash (intern (string-upcase trap-name))
  84.                                *register-trap-table*)
  85.                       (make-rtrap :number trap-number
  86.                                   :entry entry-registers
  87.                                   :exit exit-registers))))))))))
  88.  
  89. (defun find-trap-number (name)
  90.   (let ((symbol (find-symbol (concatenate 'string "_" (string-upcase name))
  91.                              :translate*)))
  92.     (and symbol (boundp symbol) (symbol-value symbol))))
  93.  
  94. (defun old-trap-macro-function (name)
  95.   (let ((symbol (find-symbol (concatenate 'string "_" (string-upcase name))
  96.                              :ccl)))
  97.     (and symbol (fboundp symbol) (car (symbol-function symbol)))))
  98.  
  99. (defun read-entry-registers (istream &aux result)
  100.   (loop
  101.     (let ((register (read istream)))
  102.       (case register
  103.         ((d0 d1 d2 a0 a1)
  104.          (read istream) ; get rid of :
  105.          (push `(,(ccl::make-keyword register)
  106.                  ,(read-delimited-list #\newline istream))
  107.                result))
  108.         (on
  109.          (when (eq (read istream) 'exit)
  110.            (return)))
  111.         (|æKY|
  112.          (return))
  113.         ((#\: #\newline))
  114.         (t
  115.          (read-line istream)))))
  116.   (nreverse result))
  117.  
  118.  
  119. (defun read-exit-registers (istream &aux result)
  120.   (loop
  121.     (let ((register (read istream)))
  122.       (case register
  123.         ((d0 d1 d2 a0 a1)
  124.          (read istream) ; get rid of :
  125.          (push `(,(ccl::make-keyword register)
  126.                  ,(read-delimited-list #\newline istream))
  127.                result))
  128.         ((|æKY| #\newline)
  129.          (return))
  130.         (#\:)
  131.         (t
  132.          (read-line istream)))))
  133.   (nreverse result))
  134.  
  135. ; Make this stuff fast to get at.
  136. (defun dump-411-traps (&optional (file (ccl::choose-new-file-dialog)))
  137.   (with-open-file (stream file :direction :output :if-exists :supersede)
  138.     (format stream "(in-package :translate)~%")
  139.     (let ((f #'(lambda (key value)
  140.                  (dump-trap key value stream))))
  141.       (declare (dynamic-extent f))
  142.       (maphash f *register-trap-table*))))
  143.  
  144. (defvar *translate-package* (find-package :translate))
  145.  
  146. (defmacro def-411-trap (name &key number entry exit)
  147.   `(%def-411-trap ',name :number ,number :entry ,entry :exit ,exit))
  148.  
  149. (defun %def-411-trap (name &key number entry exit)
  150.   (setf (gethash name *register-trap-table*)
  151.         (make-rtrap :number number
  152.                     :entry entry
  153.                     :exit exit))
  154.   name)
  155.  
  156. (defun dump-trap (key value stream)
  157.   (let ((*print-case* :downcase)
  158.         (*print-pretty* t)
  159.         (*package* *translate-package*))
  160.     (print `(def-411-trap ,key
  161.               :number ',(rtrap-number value)
  162.               :entry ',(rtrap-entry value)
  163.               :exit ',(rtrap-exit value))
  164.            stream)
  165.     (write-char #\newline stream)))
  166.     
  167.  
  168.